home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 010 / solitair.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1984-04-24  |  9.4 KB  |  298 lines
  1. 10  REM $LINESIZE:132
  2. 20  REM ----------------------------------------------------------------------
  3. 30  REM
  4. 40  REM           The Game of Klondyke Solitar
  5. 50  REM           By:  Jeff Littlefield
  6. 60  REM           For: the IBM PC and the Color Graphics Card
  7. 70  REM
  8. 80  REM           FOR PUBLIC USE    MAY NOT BE SOLD
  9. 90  REM           ALL  RIGHTS  RESERVED
  10. 100  REM
  11. 110  REM ---------------------------------------------------------------------
  12. 120  DEFINT  A-Z
  13. 130  FALSE=0:TRUE = NOT FALSE : ABORT = FALSE : WON = FALSE
  14. 140  DIM DECK$(52), STACK$(7,21),CARD$(52),TOP$(4),STACKPTR(7),VISIPTR(7),XYARR$(82)
  15. 145  NOT.READ=TRUE
  16. 150  KEY OFF: KEY(1) ON: ON KEY(1) GOSUB 950
  17. 160  RANDOMIZE(VAL(MID$(TIME$,7,2))+(VAL(MID$(TIME$,4,2))*60))
  18. 170  SCREEN 0,1,0,0:COLOR 7,1,1:CLS:PRINT"Pardon me while I shuffle the deck."
  19. 180  GOSUB 810 : GOTO 200 'SET UP THE HELP SCREEN
  20. 200  GOSUB 290            'SHUFFLE THE DECK
  21. 210  CLS
  22. 220  GOSUB 570            'PRINT OUT THE PLAYING TABLE
  23. 225  WON = FALSE
  24. 230  GOTO 970
  25. 240  IF FLAG=1 THEN GOSUB 2420 ELSE GOSUB 2070
  26. 250  IF ABORT THEN ABORT = FALSE : GOTO 230
  27. 260  FLAG=0:GOSUB 2320           'ASK IF THEY WANT TO PLAY AGAIN
  28. 270  IF ABORT THEN ABORT = FALSE : GOTO 230
  29. 280  CLS:IF FLAG=1 THEN 170 ELSE KEY ON:COLOR 7,0,0:CLS:END
  30. 290  RESTORE
  31. 300  FOR I=1 TO 52:READ CARD$(I):NEXT I
  32. 310  FOR I= 52 TO 1 STEP -1
  33. 320      X=INT(RND(1)*I)+1       'PICK NUMBER FROM 1 TO I
  34. 330      DECK$(I)=CARD$(X)       'PICK THAT CARD OUT OF THE PILE
  35. 340      CARD$(X)=CARD$(I)       'MOVE LAST CARD TO WHERE PREVIOUS ONE WAS
  36. 350  NEXT I
  37. 360  X=1                         'DECK COUNTER
  38. 370  FOR I=1 TO 7                'NUMBER OF STACKS
  39. 380    FOR J=1 TO I              'NUMBER OF CARDS IN THAT STACK
  40. 390      STACK$(I,J)=DECK$(X)    'ASSIGN CARDS TO STACK
  41. 400      X=X+1
  42. 410    NEXT J
  43. 420    STACKPTR(I)=I             'SET STACKPTR(I) TO LAST CARD IN EACH STACK
  44. 430    VISIPTR(I)=I              'SAME WITH VISIPTR(I)
  45. 440  NEXT I
  46. 450  DECKPTR=31:ENDDECK=52:DECK$(28)="   ":NC=24
  47. 460  DATA" AH"," 2H"," 3H"," 4H"," 5H"," 6H"," 7H"," 8H"," 9H","10H"," JH"," QH"," KH"
  48. 470  DATA" AD"," 2D"," 3D"," 4D"," 5D"," 6D"," 7D"," 8D"," 9D","10D"," JD"," QD"," KD"
  49. 480  DATA" AC"," 2C"," 3C"," 4C"," 5C"," 6C"," 7C"," 8C"," 9C","10C"," JC"," QC"," KC"
  50. 490  DATA" AS"," 2S"," 3S"," 4S"," 5S"," 6S"," 7S"," 8S"," 9S","10S"," JS"," QS"," KS"
  51. 500  FOR I=1 TO 7
  52. 510    STACK$(I,0)="   "
  53. 520  NEXT I
  54. 530  FOR I=1 TO 4
  55. 540    TOP$(I)="   "
  56. 550  NEXT I
  57. 560  RETURN
  58. 570  COLOR 3,1 :LOCATE 1,4:PRINT"TOP:":LOCATE 1,65:PRINT "Time: "
  59. 580  LOCATE 3,1:PRINT"STACKS:"
  60. 590  FOR I=7 TO 1 STEP -1
  61. 600    LOCATE  3,(45-(5*I))
  62. 610    PRINT I;
  63. 620  NEXT I
  64. 630  COLOR 7,1
  65. 640  FOR I=1 TO 7
  66. 650   FOR J=I TO 7
  67. 660      LOCATE (I+3),(45-(J*5))
  68. 670      IF VISIPTR(J)=I THEN C$=STACK$(J,I):GOSUB 2670:PRINT STACK$(J,I);:COLOR 7,1 ELSE FOR X=1 TO 3:PRINT CHR$(254);:NEXT X
  69. 680   NEXT J
  70. 690  NEXT I
  71. 700  COLOR 3,1
  72. 710  LOCATE 10 ,53:PRINT"PILE:";
  73. 720  COLOR 7,1
  74. 730  LOCATE 10,59:C$=DECK$(DECKPTR):GOSUB 2670:PRINT DECK$(DECKPTR);:COLOR 3,1:LOCATE 10,65:PRINT"Count: ";:COLOR 7:PRINT NC;:COLOR 3
  75. 740  LOCATE 11,64:PRINT"Card #: ";:COLOR 7:PRINT DECKPTR-28;"  ";
  76. 750  COLOR 3:LOCATE 12,50:PRINT"COMMAND: __  ";
  77. 760  COLOR 2
  78. 770  LOCATE 24,24:PRINT"Press F1 for a list of Commands";
  79. 780  COLOR 7
  80. 790  LOCATE 12,59
  81. 800  RETURN
  82. 810  SCREEN 0,1,1,0
  83. 820  CLS
  84. 830  LOCATE 10,10:PRINT"C    Claim Victory"
  85. 840  LOCATE 11,10:PRINT"N    New Card on Pile"
  86. 850  LOCATE 12,10:PRINT"P#   Card on Pile to Specified Stack"
  87. 860  LOCATE 13,10:PRINT"PT   Card on Pile to Top"
  88. 870  LOCATE 14,10:PRINT"##   Visible Cards on Stack to New Specified Stack"
  89. 880  LOCATE 15,10:PRINT"#T   Bottom Card on Specified Stack to Top"
  90. 890  LOCATE 16,10:PRINT"Q    Quit"
  91. 900  LOCATE 17,10:PRINT"F1   For This Screen"
  92. 910  COLOR 12:LOCATE 18,10:PRINT"Esc  Abort End and Return to Present Game
  93. 920  COLOR 2:LOCATE 22,28:PRINT"Press Any Key To Continue":COLOR 7
  94. 930  SCREEN 0,1,0,0
  95. 940  RETURN
  96. 950  SCREEN 0,1,0,1
  97. 960  A$=INKEY$:IF A$="" THEN 960 ELSE 930
  98. 970  FLAG=0:GOSUB 1640:IF FLAG=1 THEN 240
  99. 980  LOCATE 12,59:PRINT"__  ";:LOCATE 12,59
  100. 990  K$=INKEY$:IF K$="" THEN LOCATE 1,71:PRINT TIME$;:LOCATE 12,59:GOTO 990 ELSE PRINT K$;
  101. 1000  IF K$="N" OR K$="n" THEN 1060
  102. 1010  IF K$="P" OR K$="p" THEN 1140
  103. 1020  IF K$>="1"AND K$<="7" THEN 1700
  104. 1030  IF K$="Q" OR K$="q" THEN FLAG=0:GOTO 240
  105. 1040  IF K$="C" OR K$="c" THEN  2440
  106. 1050  SOUND 50,5:GOTO 980
  107. 1060  IF DECKPTR+3>ENDDECK THEN DECKPTR=28
  108. 1070  X=ENDDECK-28
  109. 1080  IF X <=3 THEN DECKPTR=ENDDECK ELSE DECKPTR=DECKPTR+3
  110. 1090  LOCATE 10,59
  111. 1100  C$=DECK$(DECKPTR):GOSUB 2670:PRINT DECK$(DECKPTR):COLOR 7,1
  112. 1110  LOCATE 11,72:PRINT DECKPTR-28;"  ";
  113. 1120  GOTO 980
  114. 1130  K$=INKEY$:IF K$="" THEN 1130 ELSE PRINT K$;:RETURN
  115. 1140  GOSUB 1130
  116. 1150  IF(K$="t" OR K$="T") OR (K$>="1" AND K$<="7") THEN 1160 ELSE SOUND 50,5:GOTO 980
  117. 1160  W$=DECK$(DECKPTR)
  118. 1170  SUIT$=MID$(W$,3,1):SIZE$=MID$(W$,2,1)
  119. 1180  IF K$="T" OR K$="t" THEN GOSUB 1360:GOTO 1260
  120. 1190  K=VAL(K$)
  121. 1200  W1$=STACK$(K,STACKPTR(K))
  122. 1210  SUITST$=MID$(W1$,3,1):SIZEST$=MID$(W1$,2,1)
  123. 1220  FLAG=0:GOSUB 1430:IF FLAG=0 THEN SOUND 50,5 :GOTO 970
  124. 1230  STACKPTR(K)=STACKPTR(K)+1
  125. 1240  STACK$(K,STACKPTR(K))=W$
  126. 1250  LOCATE STACKPTR(K)+3,(45-(K*5)):C$=W$:GOSUB 2670:PRINT W$:COLOR 7,1
  127. 1260  DECKPTR=DECKPTR-1:GOSUB 1300
  128. 1270  LOCATE 10,59:IF DECKPTR>28 THEN C$=DECK$(DECKPTR):GOSUB 2670:PRINT DECK$(DECKPTR):COLOR 7,1 ELSE PRINT"   "
  129. 1280  LOCATE 11,72:PRINT DECKPTR-28;"  ";
  130. 1290  GOTO 970
  131. 1300  IF DECKPTR+1=ENDDECK THEN 1340
  132. 1310  FOR I= DECKPTR+2 TO ENDDECK
  133. 1320  DECK$(I-1)=DECK$(I)
  134. 1330  NEXT I
  135. 1340  ENDDECK=ENDDECK-1:NC=NC-1:LOCATE 10,72:PRINT NC;
  136. 1350  RETURN
  137. 1360  IF SUIT$="C" THEN N=1:GOTO 1400
  138. 1370  IF SUIT$="D" THEN N=2:GOTO 1400
  139. 1380  IF SUIT$="H" THEN N=3:GOTO 1400
  140. 1390  N=4
  141. 1400  SIZEST$=MID$(TOP$(N),2,1)
  142. 1410  FLAG=0:GOSUB 1550:IF FLAG=0 THEN SOUND 50,5:GOTO 970
  143. 1420  TOP$(N)=W$:LOCATE 1,10+(10*(N-1)):C$=W$:GOSUB 2670:PRINT W$:COLOR 7,1:RETURN
  144. 1430  IF(SUIT$="H"OR SUIT$="D")AND(SUITST$="H"OR SUITST$="D") THEN RETURN
  145. 1440  IF(SUIT$="C"OR SUIT$="S")AND(SUITST$="C"OR SUITST$="S") THEN RETURN
  146. 1450  IF SIZE$>"9" THEN 1490
  147. 1460  IF SIZE$="0" AND SIZEST$="J" THEN 1540
  148. 1470  IF SIZE$="9" AND SIZEST$="0" THEN 1540
  149. 1480  IF (ASC(SIZEST$)-ASC(SIZE$))=1 THEN 1540
  150. 1490  IF SIZE$="A" AND SIZEST$="2" THEN 1540
  151. 1500  IF SIZE$="J" AND SIZEST$="Q" THEN 1540
  152. 1510  IF SIZE$="Q" AND SIZEST$="K" THEN 1540
  153. 1520  IF SIZE$="K" AND SIZEST$=" " THEN 1540
  154. 1530  RETURN
  155. 1540  FLAG=1:RETURN
  156. 1550  IF SIZE$="A" AND SIZEST$=" " THEN 1630
  157. 1560  IF SIZE$="2" AND SIZEST$="A" THEN 1630
  158. 1570  IF SIZE$="0" AND SIZEST$="9" THEN 1630
  159. 1580  IF (ASC(SIZE$)-ASC(SIZEST$))=1 THEN 1630
  160. 1590  IF SIZE$="J" AND SIZEST$="0" THEN 1630
  161. 1600  IF SIZE$="Q" AND SIZEST$="J" THEN 1630
  162. 1610  IF SIZE$="K" AND SIZEST$="Q" THEN 1630
  163. 1620  RETURN
  164. 1630  FLAG=1:RETURN
  165. 1640  REM  CHECK TO SEE IF THE GAME IS OVER
  166. 1650  FOR I=1 TO 4
  167. 1660  IF MID$(TOP$(I),2,1)<>"K" THEN RETURN
  168. 1670  NEXT I
  169. 1680  REM GAME OVER AND PLAYER WON
  170. 1690  FLAG=1:RETURN
  171. 1700  REM STACK TO STACK MOVE OR STACK TO TOP
  172. 1710  STKNUM1=VAL(K$)
  173. 1720  GOSUB 1130
  174. 1730  IF (K$>="1" AND K$<="7") OR (K$="T" OR K$="t") THEN 1750
  175. 1740  SOUND 50,5:GOTO 980
  176. 1750  IF K$="t" OR K$="T" THEN W$=STACK$(STKNUM1,STACKPTR(STKNUM1)):GOTO 1770
  177. 1760  W$=STACK$(STKNUM1,VISIPTR(STKNUM1))
  178. 1770  SUIT$=MID$(W$,3,1)
  179. 1780  SIZE$=MID$(W$,2,1)
  180. 1790  IF K$="T" OR K$="t" THEN GOSUB 1360:GOTO 2020
  181. 1800  STKNUM2=VAL(K$)
  182. 1810  W$=STACK$(STKNUM2,STACKPTR(STKNUM2))
  183. 1820  SUITST$=MID$(W$,3,1)
  184. 1830  SIZEST$=MID$(W$,2,1)
  185. 1840  FLAG=0:GOSUB 1430
  186. 1850  IF FLAG=0 THEN SOUND 50,5:GOTO 980
  187. 1860  IF VISIPTR(STKNUM1)=0 THEN VISIPTR(STKNUM1)=1
  188. 1870  FOR I=VISIPTR(STKNUM1) TO STACKPTR(STKNUM1)
  189. 1880  STACKPTR(STKNUM2)=STACKPTR(STKNUM2)+1
  190. 1890  LOCATE I+3,45-(STKNUM1*5):PRINT"   ";
  191. 1900  STACK$(STKNUM2,STACKPTR(STKNUM2))=STACK$(STKNUM1,I)
  192. 1910  LOCATE STACKPTR(STKNUM2)+3,45-(STKNUM2*5)
  193. 1920  C$ =  STACK$(STKNUM2,STACKPTR(STKNUM2)):GOSUB 2670
  194. 1930  PRINT STACK$(STKNUM2,STACKPTR(STKNUM2));:COLOR 7,1
  195. 1940  NEXT I
  196. 1950  IF VISIPTR(STKNUM1)>0 THEN VISIPTR(STKNUM1)=VISIPTR(STKNUM1)-1
  197. 1960  STACKPTR(STKNUM1)=VISIPTR(STKNUM1)
  198. 1970  IF STACKPTR(STKNUM1)<1 THEN 970
  199. 1980  LOCATE STACKPTR(STKNUM1)+3,45-(STKNUM1*5)
  200. 1990  C$ =  STACK$(STKNUM1,STACKPTR(STKNUM1)):GOSUB 2670
  201. 2000  PRINT STACK$(STKNUM1,STACKPTR(STKNUM1));:COLOR 7,1
  202. 2010  GOTO 970
  203. 2020  LOCATE STACKPTR(STKNUM1)+3,45-(STKNUM1*5)
  204. 2030  PRINT"   ";
  205. 2040  IF STACKPTR(STKNUM1)=VISIPTR(STKNUM1) THEN 1950
  206. 2050  STACKPTR(STKNUM1)=STACKPTR(STKNUM1)-1
  207. 2060  GOTO 970
  208. 2070  REM PRINT OUT THE TABLE
  209. 2080  COLOR 2 : SEEN = FALSE
  210. 2090  LOCATE 24,24:PRINT"Would you like to see the cards? "; :SOUND 1975,1:GOSUB 2550 : SOUND 1975,1
  211. 2100  A$=INKEY$:IF A$="" THEN 2100
  212. 2110  IF A$=CHR$(27) THEN ABORT=TRUE : LOCATE 24,24:PRINT SPACE$(40);:COLOR 7 : RETURN :ELSE ABORT=FALSE
  213. 2120  IF A$<>"y" AND A$<>"Y" AND A$<>"N" AND A$<>"n" THEN SOUND 50,5:GOTO 2100
  214. 2130  IF A$="N" OR A$="n" THEN 2300
  215. 2140  SEEN = TRUE : LOCATE 24,24:PRINT "                                    ";
  216. 2150  FOR I=7 TO 1 STEP -1
  217. 2160  X=1
  218. 2170  WHILE VISIPTR(I)>X
  219. 2180  LOCATE X+3,45-(I*5)
  220. 2190  PRINT STACK$(I,X);:X=X+1
  221. 2200  WEND
  222. 2210  NEXT I
  223. 2220  LOCATE 18,50:PRINT"Pile: "
  224. 2230  X=0:RR=18
  225. 2240  FOR I=29 TO ENDDECK
  226. 2250  IF X+56>76 THEN RR=RR+1:X=0
  227. 2260  LOCATE RR,X+56
  228. 2270  IF DECK$(I)="   "THEN 2300 ELSE PRINT DECK$(I);:X=X+4
  229. 2280  NEXT I
  230. 2290  COLOR 7
  231. 2300  RETURN
  232. 2310  COLOR 2
  233. 2320  IF SCR.WIDTH=40 THEN SCR.WIDTH =80:LOCATE 24,15:PRINT"Play Again?";:GOTO 2340 ELSE LOCATE 24,24
  234. 2330  LOCATE 24,24:PRINT"     Do you want to play again?                     ";
  235. 2340  A$=INKEY$:IF A$="" THEN 2340
  236. 2350  IF NOT WON THEN COLOR 7
  237. 2360  IF A$<>CHR$(27) THEN 2390 ELSE IF NOT SEEN AND NOT WON THEN ABORT=TRUE :LOCATE 24,28:PRINT SPACE$(30);:RETURN
  238. 2365  IF WON THEN SOUND 50,5: GOTO 2340
  239. 2370  SOUND 50,5:LOCATE 24,17:PRINT"Cheater... Shame Shame!  You've already seen the cards!";:DT!=2000:GOSUB 2570
  240. 2380  LOCATE 24,17 : PRINT SPACE$(60);:GOTO 2320
  241. 2390  IF A$="y" OR A$="Y" THEN GOSUB 2870:FLAG =1:RETURN
  242. 2400  IF A$="N" OR A$="n" THEN GOSUB 2870:RETURN
  243. 2410  SOUND 50,5:GOTO 2340
  244. 2420  GOSUB 2700
  245. 2430  RETURN
  246. 2440  'CHECK TO SEE IF CLAIMED VICTORY
  247. 2450  FLAG=0
  248. 2460  IF NC>0 THEN 2510
  249. 2470  FOR I=1 TO 7
  250. 2480  IF VISIPTR(I)>1 THEN 2510
  251. 2490  NEXT I
  252. 2500  FLAG=1:GOTO 240
  253. 2510  SOUND 50,5:LOCATE 14,50:PRINT"You Have Not Won Yet!!!"
  254. 2520  DT! = 2000 : GOSUB 2570
  255. 2530  LOCATE 14,50:PRINT SPC(25);
  256. 2540  GOTO 980
  257. 2550  'DELAY TIME ROUTINE FOR (DT!) MILLISECONDS
  258. 2560  DT!=250
  259. 2570  DV!=DT!*18.2/1000
  260. 2580  DEF SEG = &H40
  261. 2590  WHILE DV!>0
  262. 2600     A! = O
  263. 2610     FOR ID = O TO 3
  264. 2620     A! = A!*256 + PEEK(&H6F-ID)
  265. 2630     NEXT ID
  266. 2640     IF A! <> AOLD! THEN DV! = DV! - 1 : AOLD! = A!
  267. 2650  WEND
  268. 2660  DEF SEG : RETURN
  269. 2670  C$=MID$(C$,3,1)
  270. 2680  IF C$="H" OR C$="D" THEN COLOR 12,7 ELSE COLOR 0,7
  271. 2690  RETURN
  272. 2700  REM 'DISPLAY WON SCREEN'
  273. 2710  IF NOT.READ THEN FOR I = 1 TO 82 : READ XYARR$(I) : NEXT : NOT.READ=FALSE
  274. 2730  SCREEN 1,0 : COLOR 1,0
  275. 2740  FOR I = 82 TO 1 STEP -1
  276. 2750  FOR J = 1 TO 45
  277. 2760  X=RND(1)*320:Y=RND(1)*200:C=C+1:IF C=4 THEN C=1
  278. 2770  PSET (X,Y),C
  279. 2780  NEXT J
  280. 2790  LL = INT(RND(1)*I)+1
  281. 2800  XYPOS$=XYARR$(LL)
  282. 2810  XYARR$(LL)=XYARR$(I)
  283. 2820  Y = VAL(LEFT$(XYPOS$,1))+8
  284. 2830  X= VAL(RIGHT$(XYPOS$,2))
  285. 2840  LOCATE Y,X:PRINT "*";
  286. 2850  NEXT I
  287. 2860  SCR.WIDTH=40 : WON = TRUE : RETURN
  288. 2870  SCREEN 0,0,0,0:WIDTH 80:RETURN
  289. 2880   DATA "002","006","009","010","011","014","018","023","027","030"
  290. 2890   DATA "031","032","035","039","103","105","108","112","114"
  291. 2900   DATA "118","123","127","129","133","135","136","139","204","208"
  292. 2910   DATA "212","214","218","223","225","227","229","233","235","236"
  293. 2920   DATA "237","239","304","308","312","314","318","323","325","327"
  294. 2930   DATA "329","333","335","337","338","339","404","408","412","414"
  295. 2940   DATA "418","423","425","427","429","433","435","438","439","504"
  296. 2950   DATA "509","510","511","515","516","517","524","526","530","531"
  297. 2960   DATA "532","535","539"
  298.